home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / letmac.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  4.0 KB  |  135 lines
  1. ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;;     The data in this file contains enhancments.                    ;;;;;
  4. ;;;                                                                    ;;;;;
  5. ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
  6. ;;;     All rights reserved                                            ;;;;;
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8.  
  9. (in-package "MAXIMA")
  10. ;; Destructuring DEFUN must be added to this at some point.
  11.  
  12. (declare-top (special let-macro-vals))
  13.  
  14. ;; Kludge to avoid warning that a different file is redefining
  15. ;; LET and LET*.  SI has LET and LET* externed, so there is no
  16. ;; "illegally defining" warning.
  17.  
  18. (defmacro let (pairs &body body)
  19.        (do ((pairs pairs (cdr pairs))
  20.         (vars nil)
  21.         (let-macro-vals nil)
  22.         (tem))
  23.        ((null pairs)
  24.         (cond ((not (null vars))
  25.            ;`((lambda ,(reverse vars) . ,body) .
  26.            ;,(reverse let-macro-vals))
  27.            `(lisp:let ,(nreverse (sloop for v in vars for w in
  28.                       let-macro-vals collect
  29.                       (list v w)))
  30.                   ,@ body)
  31.            )
  32.           ((null (cdr body))
  33.            (car body))
  34.           (t `(progn . ,body))))
  35.        (cond ((atom (car pairs))
  36.           (or (symbolp (car pairs))
  37.               (error 
  38.                   "Garbage found in LET pattern: ~S" (car pairs)))
  39.           (setq vars (cons (car pairs) vars))
  40.           (setq let-macro-vals (cons nil let-macro-vals)))
  41.          (t
  42.           (setq tem vars)
  43.           (setq vars (let-macro-get-vars (caar pairs) vars))
  44.           (or (eq tem vars)
  45.               (setq body (nconc (let-macro-hair (caar pairs)
  46.                             (cadar pairs)
  47.                             let-macro-vals)
  48.                     body)))))))
  49.  
  50. (defun let-macro-get-vars (pattern vars)
  51.        (cond ((null pattern) vars)
  52.          ((atom pattern)
  53.           (or (symbolp pattern)
  54.           (error 
  55.               "Garbage found in LET pattern: ~S" pattern))
  56.           (setq let-macro-vals (cons nil let-macro-vals))
  57.           (cons pattern vars))
  58.          (t (let-macro-get-vars (cdr pattern)
  59.                     (let-macro-get-vars (car pattern) vars)))))
  60.  
  61. (defmacro desetq (&rest p)
  62.        (do ((p p (cddr p))
  63.         (body nil)
  64.         (tem))
  65.        ((null p)
  66.         `(progn . ,body))
  67.        (cond ((atom (cdr p))
  68.           (error 
  69.               "Odd number of args to DESETQ: ~S" p))
  70.          ((atom (car p))
  71.           (or (symbolp (car p))
  72.               (error 
  73.                   "Garbage found in DESETQ pattern: ~S" (car p)))
  74.           (and (null (car p))
  75.                (error 
  76.                    "Bad DESETQ pattern: ~S" (car p)))
  77.           (setq body (nconc body `((setq ,(car p) ,(cadr p))))))
  78.          (t
  79.           (setq tem (cons nil nil))
  80.           (setq body (nconc body
  81.                     `((setq ,(let-macro-get-last-var (car p))
  82.                         . ,tem)
  83.                       . ,(let-macro-hair (car p) (cadr p) tem))))))))
  84.  
  85.  
  86. (defun let-macro-get-last-var (pattern)
  87.        (cond ((atom pattern) pattern)
  88.          (t
  89.           (or (let-macro-get-last-var (cdr pattern))
  90.           (let-macro-get-last-var (car pattern))))))
  91.  
  92. (defun let-macro-hair (pattern code cell)
  93.        (cond ((null pattern) nil)
  94.          ((atom pattern)
  95.           (rplaca cell code)
  96.           nil)
  97.          (t
  98.           ((lambda (avar dvar)
  99.             (cond ((null avar)
  100.                (cond ((null dvar) nil)
  101.                  (t (let-macro-hair (cdr pattern)
  102.                             `(cdr ,code)
  103.                             cell))))
  104.               ((null dvar)
  105.                (let-macro-hair (car pattern)
  106.                        `(car ,code)
  107.                        cell))
  108.               (t
  109.                (rplaca cell code)
  110.                ((lambda (acell dcell)
  111.                  (cons `(setq ,avar . ,acell)
  112.                        (nconc (let-macro-hair (car pattern)
  113.                                   `(car ,dvar)
  114.                                   acell)
  115.                           (cons `(setq ,dvar . ,dcell)
  116.                             (let-macro-hair (cdr pattern)
  117.                                     `(cdr ,dvar)
  118.                                     dcell)))))
  119.                 (cons nil nil)
  120.                 (cons nil nil)))))
  121.            (let-macro-get-last-var (car pattern))
  122.            (let-macro-get-last-var (cdr pattern))))))
  123.  
  124. (defmacro let* (pairs &body body)
  125.   (cond ((sloop for v in pairs
  126.         always (or (symbolp v) (and (consp v) (symbolp (car v)))))
  127.      `(lisp::let* ,pairs ,@body))
  128.     (t
  129.       (do ((a (reverse pairs) (cdr a))
  130.            (b body `((let (,(car a)) . ,b))))
  131.           ((null a)
  132.            (cond ((null (cdr b)) (car b))
  133.              (t `(progn . ,b))))))))
  134.  
  135.